home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
scheme
/
boxer
/
boxer.lha
/
fnctns.lisp
< prev
next >
Wrap
Text File
|
1993-07-17
|
10KB
|
237 lines
;; -*- Mode:LISP; Package:(BOXER GLOBAL 1000); Base:10.; Fonts:CPTFONT -*-
;;
;; (C) Copyright 1982 Massachusetts Institute of Technology
;;
;; Permission to use, copy, modify, distribute, and sell this software
;; and its documentation for any purpose is hereby granted without fee,
;; provided that the above copyright notice appear in all copies and that
;; both that copyright notice and this permission notice appear in
;; supporting documentation, and that the name of M.I.T. not be used in
;; advertising or publicity pertaining to distribution of the software
;; without specific, written prior permission. M.I.T. makes no
;; representations about the suitability of this software for any
;; purpose. It is provided "as is" without express or implied warranty.
;;
;;
;; This file is part of the BOXER system.
;;
;; Evaluator utility functions.
;;; Define BOXER-FUNCTION-SPECs. Boxer-function-specs have one of the
;;; following forms:
;;; (:BOXER-FUNCTION <symbol>)
;;; (:BOXER-FUNCTION <a doit box>)
;;;
;;; Note that we need to have this a compile load and eval times!!
(EVAL-WHEN (COMPILE LOAD EVAL)
(PUTPROP ':BOXER-FUNCTION 'BOXER-FUNCTION-SPEC-HANDLER 'SYS:FUNCTION-SPEC-HANDLER)
(DEFUN BOXER-FUNCTION-SPEC-HANDLER (OP FUNCTION-SPEC &OPTIONAL ARG1 ARG2)
(LET ((SYMBOL-OR-BOX (CADR FUNCTION-SPEC)))
(SELECTQ OP
(SI:VALIDATE-FUNCTION-SPEC (OR (SYMBOLP SYMBOL-OR-BOX)
(DOIT-BOX? SYMBOL-OR-BOX)))
(SI:FDEFINE (COND ((SYMBOLP SYMBOL-OR-BOX)
;; If its a symbol, we put the function
;; in its value cell, and add the symbol
;; to the list of *boxer-functions*.
(SET SYMBOL-OR-BOX ARG1)
(UNLESS (MEMQ SYMBOL-OR-BOX *BOXER-FUNCTIONS*)
(PUSH SYMBOL-OR-BOX *BOXER-FUNCTIONS*)))
(T
;; If its a doit-box, we put the function
;; in the cached-code slot of the doit-box.
(SEND SYMBOL-OR-BOX ':SET-CACHED-CODE ARG1))))
(SI:FDEFINEDP (COND ((SYMBOLP SYMBOL-OR-BOX)
(AND (BOUNDP SYMBOL-OR-BOX)
(LET ((SYMBOL-VALUE (SYMEVAL SYMBOL-OR-BOX)))
(OR (FUNCTIONP SYMBOL-VALUE)
;(FDEFINEDP SYMBOL-VALUE)
(BOXER-FUNCTION? SYMBOL-VALUE)
(BOXER-FDEFINED? SYMBOL-VALUE)))))
((DOIT-BOX? SYMBOL-OR-BOX)
T)))
(SI:FDEFINITION (COND ((SYMBOLP SYMBOL-OR-BOX)
(UNLESS (NOT (BOUNDP SYMBOL-OR-BOX))
(LET ((SYMBOL-VALUE (SYMEVAL SYMBOL-OR-BOX)))
(COND ((AND (SYMBOLP SYMBOL-VALUE)
(FDEFINEDP SYMBOL-VALUE))
(FDEFINITION SYMBOL-VALUE))
((FUNCTIONP SYMBOL-VALUE) SYMBOL-VALUE)
(T
(BOXER-FDEFINITION SYMBOL-VALUE))))))
((DOIT-BOX? SYMBOL-OR-BOX)
(SEND SYMBOL-OR-BOX ':CODE))
(T
(FERROR "Boxer-Fn-Spec Error."))))
(SI:FDEFINITION-LOCATION (IF (SYMBOLP SYMBOL-OR-BOX)
(VALUE-CELL-LOCATION SYMBOL-OR-BOX)
(TELL SYMBOL-OR-BOX ':CODE-LOCATION)))
(SI:FUNDEFINE (IF (SYMBOLP SYMBOL-OR-BOX)
(MAKUNBOUND SYMBOL-OR-BOX)))
(OTHERWISE
(SI:FUNCTION-SPEC-DEFAULT-HANDLER OP FUNCTION-SPEC ARG1 ARG2)))))
(DEFMETHOD (DOIT-BOX :VALIDATE-FUNCTION-SPEC) ()
':BOXER-FUNCTION)
;; BOXER-FUNCALL is funcall for boxer-functions
;; --Always use BOXER-FUNCALL!!! Always use BOXER-FUNCALL!!!--
;; Note well that:
;; (BOXER-FUNCALL 'FOO <args>)
;; is not necessarily the same as:
;; (FUNCALL (BOXER-GET-ACTUAL-FUNCTION 'FOO) <args>)
;; --Never use ordinary funcall! Never use ordinary funcall!--
(DEFUN BOXER-FUNCALL (X &REST ARGS)
(COND ((AND (SYMBOLP X) (FDEFINEDP X)) (APPLY X ARGS))
((AND (SYMBOLP X) (NOT (POINTS-TO-SELF X)))
(LEXPR-FUNCALL #'BOXER-FUNCALL (BOXER-SYMEVAL X) ARGS))
((NOT (BOXER-FUNCTION? X))
(FERROR "~S is not a Boxer Function. " X))
(T (BOXER-APPLY X ARGS))))
;;; Boxer primitives which are written in lisp
;;; we need to be able to get the function, the arglist, and the eval markers in the arglist
;;; for each arg as they are needed
;;; we should be able to optionally specify a box that we want the function to be installed
;;; inside of. This implies that we won't be able to stick needed info on the plist of
;;; the symbol since a function can have the same name in many different boxes. Also,
;;; by the time we are interested in getting the arglist information of a primitive, we will
;;; be dealing with function objects, the associated symbol has already been symeval'd
(DEFSUBST FLAVORED-ARGLIST? (ARGLIST)
(SUBSET #'LISTP ARGLIST))
(DEFMACRO DEFBOXER-LOCAL-FUNCTION (FN-NAME IN-BOX . ARGS)
(LET ((DUMMY-NAME (INTERN-IN-BU-PACKAGE (STRING-APPEND FN-NAME "-INTERNAL" (GENSYM "-"))))
(BINDING-NAME (INTERN-IN-BU-PACKAGE FN-NAME)))
(IF (NULL (FLAVORED-ARGLIST? (CAR ARGS)))
`(PROGN
(COMPILE '(:BOXER-FUNCTION ,DUMMY-NAME)
'(LAMBDA ,(CAR ARGS) ,@(CDR ARGS)))
(TELL ,IN-BOX :ADD-STATIC-VARIABLE-PAIR ',BINDING-NAME ,DUMMY-NAME))
`(PROGN
(COMPILE '(:BOXER-FUNCTION ,DUMMY-NAME)
'(LAMBDA ,(GET-ARG-NAMES-FROM-ARGLIST (CAR ARGS))
,@(CDR ARGS)))
(SET-ARGS-TEMPLATE ,DUMMY-NAME ',(GET-TEMPLATE-FROM-ARGLIST (CAR ARGS)))
(TELL ,IN-BOX :ADD-STATIC-VARIABLE-PAIR ',BINDING-NAME ,DUMMY-NAME)))))
;; this doesn't remove old entries in special arglist table on redefinition
;; flavored input templates should be stored with the function objects anyway...
(DEFMACRO DEFBOXER-FUNCTION (FN-NAME . ARGS)
(COND
((AND (NOT (NULL (CAR ARGS))) (SYMBOLP (CAR ARGS)) (BOXER-EDITOR-COMMAND? (CAR ARGS)))
;; this is doing the duty of SET-KEY
`(PROGN 'COMPILE
(RECORD-COMMAND-KEY ',(INTERN-IN-BU-PACKAGE FN-NAME) ',(CAR ARGS))
(DEFF (:BOXER-FUNCTION ,(INTERN-IN-BU-PACKAGE FN-NAME)) ',(CAR ARGS))))
((AND (NOT (NULL (CAR ARGS))) (SYMBOLP (CAR ARGS)))
;; handle the DEFF like form of DEFBOXER-FUNCTION
`(DEFF (:BOXER-FUNCTION ,(INTERN-IN-BU-PACKAGE FN-NAME)) ',(CAR ARGS)))
((NULL (FLAVORED-ARGLIST? (CAR ARGS)))
;; normal use without flavored inputs
`(DEFUN (:BOXER-FUNCTION ,(INTERN-IN-BU-PACKAGE FN-NAME)) . ,ARGS))
(T
;; flavored inputs
`(PROGN 'COMPILE
;; get rid of old entries in the flavored inputs table
(WHEN (FDEFINEDP '(:BOXER-FUNCTION ,(INTERN-IN-BU-PACKAGE FN-NAME)))
(REMOVE-ARGS-TEMPLATE
(FDEFINITION '(:BOXER-FUNCTION ,(INTERN-IN-BU-PACKAGE FN-NAME)))))
(DEFUN (:BOXER-FUNCTION ,(INTERN-IN-BU-PACKAGE FN-NAME))
,(GET-ARG-NAMES-FROM-ARGLIST (CAR ARGS))
,@(CDR ARGS))
;; make a new entry in the flavored inputs table
(SET-ARGS-TEMPLATE
(FDEFINITION '(:BOXER-FUNCTION ,(INTERN-IN-BU-PACKAGE FN-NAME)))
',(GET-TEMPLATE-FROM-ARGLIST (CAR ARGS)))))))
)
(DEFUN POINTS-TO-SELF (X)
(AND (SYMBOLP X) (BOXER-BOUNDP X) (EQ X (BOXER-SYMEVAL X))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Keep this code around so that the parser will still work... ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Boxer evaluation utilities.
(DEFUN BOXER-FDEFINED? (X)
(or (EVAL-DOIT? X) (functionp x)
(AND (symbolp x)
(NOT (POINTS-TO-SELF X))
(AND (BOXER-BOUNDP X) (boxer-fdefined? (BOXER-SYMEVAL X))))))
;probably this should be fixed in the function spec handler, but that's about
;to be flushed...
(DEFUN BOXER-FDEFINITION (X)
(IF (POINTS-TO-SELF X) (FERROR "~S is not a valid Boxer function." x))
(AND (OR (SYMBOLP X) (DOIT-BOX? X))
(FDEFINITION `(:BOXER-FUNCTION ,X))))
(DEFF BOXER-GET-ACTUAL-FUNCTION 'BOXER-FDEFINITION)
;;same as in EVAL
(DEFUN BOXER-FUNCTION? (THING)
(OR (EVAL-DOIT? THING) (FUNCTIONP THING)
(AND (EVAL-PORT? THING) (EVAL-DOIT? (GET-PORT-TARGET THING)))))
;;The error-detecting mechanism is somewhat of a crock. This stuff is done
;;so that the toplevel name (rather than one of its value's value's...) can
;;be reported.
(DEFUN BOXER-ARGLIST (X)
(LET ((RESULT (*CATCH 'BOXER-ARGLIST-BAD-FUNCTION
(BOXER-ARGLIST-1 X))))
(IF (STRINGP RESULT) (FERROR RESULT X)
RESULT)))
(DEFUN BOXER-ARGLIST-1 (X)
(LET ((TYPE (TYPEP X)))
(COND ((POINTS-TO-SELF X) (*THROW 'BOXER-ARGLIST-BAD-FUNCTION
"~S IS NOT A BOXER FUNCTION."))
((EQ TYPE 'DOIT-BOX) (PARSER-BOXER-ARGLIST X))
((FUNCTIONP X) (ARGLIST X))
((EQ TYPE :SYMBOL) (BOXER-ARGLIST-1 (BOXER-SYMEVAL X)))
(T (*THROW 'BOXER-ARGLIST-BAD-FUNCTION "~S IS NOT A BOXER FUNCTION")))))
#+LMITI
(deff args-info-from-lambda-list 'si:args-info-from-lambda-list)
;;Evaluator insures that x will be a function object so we don't have to worry about symbols
(DEFUN BOXER-ARGS-INFO (X)
(ARGS-INFO-FROM-LAMBDA-LIST (ARGLIST X)))
;;; old parser stuff
;(defmethod (doit-box :funcall) (args)
; (let ((*currently-executing-box* self))
; (with-dynamic-values-bound (make-frame self args)
; (cond (*step-flag*
; (let ((*step-flag* *step-flag*))
; (step-through-box *box-copy-for-stepping*))) ;crock global register
; (t (funcall (tell self :code)))))))
;;;;stuff for minimal error handling.
;;this should probably be changed to handle printing the error specially,
;;instead of just returning it as a string, but we're going to have to
;;write something special anyway as an error handler, so maybe it will
;;fit in here unmolested and just *throw out if it feels like it.
;(defun eval-row-catching-errors (row)
; (if *boxer-error-handler-p*
; (condition-case (error)
; (eval (parse-into-code row))
; (error
; (tell error :report-string)))
; (eval (parse-into-code row))))